home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload Trio 2
/
Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO
/
dir38
/
manythng.zip
/
BACKGRND.FRM
next >
Wrap
Text File
|
1993-04-15
|
42KB
|
1,506 lines
VERSION 2.00
Begin Form BackGround
BackColor = &H00000000&
BorderStyle = 0 'None
ControlBox = 0 'False
Height = 2976
Icon = BACKGRND.FRX:0000
Left = 864
LinkTopic = "Form1"
ScaleHeight = 213
ScaleMode = 3 'Pixel
ScaleWidth = 478
Top = 1260
Width = 5832
Begin Timer Tick
Interval = 50
Left = 10
Top = 10
End
End
' BackGround -- this form expands to fill the whole
' screen and is used as the back drop for all the
' drawing
Option Explicit
' variables declared here
Dim lastX, lastY ' Last position of the moves
Dim LastTime As Long
Dim CurrentTime As Long
Dim LinkTime As Long
Dim PlotType As Integer
Dim PlotInit As Integer
Dim RepeatIndex As Integer
Dim Pointer As Integer
Dim Mirror As Integer
Dim x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer
Dim vx1 As Single, vy1 As Single, vx2 As Single, vy2 As Single
Dim ax1 As Single, ax2 As Single, ay1 As Single, ay2 As Single
Dim l As Long
Dim m As Long
Dim MaxSpeedX As Integer, MaxSpeedY As Integer
Dim TimeInterval As Long
Dim MaxTime As Long
Dim Repeats As Integer
Dim i As Integer
Dim BoxHeight As Integer, BoxWidth As Integer
Dim DC As Integer
Dim Pattern As Long, Locked As Integer
Dim Direction As Integer
'Allocate Memory
Dim x1a() As Integer
Dim x2a() As Integer
Dim y1a() As Integer
Dim y2a() As Integer
Dim x1da() As Integer
Dim x2da() As Integer
Dim y1da() As Integer
Dim y2da() As Integer
Dim x1sa() As Single
Dim x2sa() As Single
Dim y1sa() As Single
Dim y2sa() As Single
Dim vx1sa() As Single
Dim vx2sa() As Single
Dim vy1sa() As Single
Dim vy2sa() As Single
Dim ax1sa() As Single
Dim ax2sa() As Single
Dim ay1sa() As Single
Dim ay2sa() As Single
Dim Colors() As Long
Dim DataPts() As Integer
Dim MaxPlotType As Integer
Sub Circles ()
' have a single elipse trace across the
' screen with multiple previous copies following
' it
Dim i As Integer, j As Integer, k As Integer, N As Integer
Dim xRadius As Integer, yRadius As Integer
' if first time then initialize
If PlotInit = False Then
PlotInit = True
Cls
Forecolor = QBColor(15)
'Set array size and clear the elements
ReDim x1a(MaxLines) As Integer
ReDim x2a(MaxLines) As Integer
ReDim y1a(MaxLines) As Integer
ReDim y2a(MaxLines) As Integer
Pointer = 1 ' start with array element 1
' set index to count number of times to repeat color
' to past maxvalue so that it will be recalculated
RepeatIndex = MaxLines + 1
'determine initial position of line
x1 = Rnd * ScaleWidth
x2 = Rnd * ScaleWidth
y1 = Rnd * ScaleHeight
y2 = Rnd * ScaleHeight
'set initial velocity
vx1 = 0
vx2 = 0
vy1 = 0
vy2 = 0
'set initial acceleration
ax1 = 0
ax2 = 0
ay1 = 0
ay2 = 0
'find background color
m = QBColor(0)
'Calculate velocity limits
MaxSpeedX = ScaleWidth * 15! / 800
MaxSpeedY = ScaleWidth * 15! / 600
Else ' put run code here
' check if time to get a new color
If RepeatIndex > RepeatCount Then
' use rgb function
i = Rnd * 255: If i > 255 Then i = 255
j = Rnd * 255: If j > 255 Then j = 255
k = Rnd * 255: If k > 255 Then k = 255
l = RGB(i, j, k)
RepeatIndex = 1
Else
RepeatIndex = RepeatIndex + 1
End If
'Delete original circle
xRadius = Abs(x1a(Pointer) - x2a(Pointer)) / 2
yRadius = Abs(y1a(Pointer) - y2a(Pointer)) / 2
If xRadius <> 0 Then
Circle ((x1a(Pointer) + x2a(Pointer)) / 2, (y1a(Pointer) + y2a(Pointer)) / 2), xRadius, m, , , yRadius / xRadius
End If
'Save New Circle
x1a(Pointer) = x1
x2a(Pointer) = x2
y1a(Pointer) = y1
y2a(Pointer) = y2
'Draw new Circle
xRadius = Abs(x1a(Pointer) - x2a(Pointer)) / 2
yRadius = Abs(y1a(Pointer) - y2a(Pointer)) / 2
If xRadius <> 0 Then
Circle ((x1a(Pointer) + x2a(Pointer)) / 2, (y1a(Pointer) + y2a(Pointer)) / 2), xRadius, l, , , yRadius / xRadius
End If
'Move pointer to next item
Pointer = Pointer + 1
If Pointer > MaxLines Then
Pointer = 1
End If
'determine new acceleration
ax1 = Rnd - .5
ax2 = Rnd - .5
ay1 = Rnd - .5
ay2 = Rnd - .5
'calculate new position
x1 = x1 + vx1
x2 = x2 + vx2
y1 = y1 + vy1
y2 = y2 + vy2
'calculate new velocity
vx1 = (vx1 + ax1): If Abs(vx1) > MaxSpeedX Then vx1 = 0: ax1 = 0
vx2 = (vx2 + ax2): If Abs(vx2) > MaxSpeedX Then vx2 = 0: ax2 = 0
vy1 = (vy1 + ay1): If Abs(vy1) > MaxSpeedY Then vy1 = 0: ay1 = 0
vy2 = (vy2 + ay2): If Abs(vy2) > MaxSpeedY Then vy2 = 0: ay2 = 0
'check if off screen
If (x1 > ScaleWidth) Then
'change direction
vx1 = -Abs(vx1)
ElseIf (x1 < 0) Then
'change direction
vx1 = Abs(vx1)
End If
If (y1 > ScaleHeight) Then
'change direction
vy1 = -Abs(vy1)
ElseIf (y1 < 0) Then
'change direction
vy1 = Abs(vy1)
End If
If (x2 > ScaleWidth) Then
'change direction
vx2 = -Abs(vx2)
ElseIf (x2 < 0) Then
'change direction
vx2 = Abs(vx2)
End If
If (y2 > ScaleHeight) Then
'change direction
vy2 = -Abs(vy2)
ElseIf (y2 < 0) Then
'change direction
vy2 = Abs(vy2)
End If
End If
End Sub
Sub ClearArrays ()
'clear arrays
ReDim x1a(0) As Integer
ReDim x2a(0) As Integer
ReDim y1a(0) As Integer
ReDim y2a(0) As Integer
ReDim x1da(0, 0) As Integer
ReDim x2da(0, 0) As Integer
ReDim y1da(0, 0) As Integer
ReDim y2da(0, 0) As Integer
ReDim x1sa(0) As Single
ReDim x2sa(0) As Single
ReDim y1sa(0) As Single
ReDim y2sa(0) As Single
ReDim vx1sa(0) As Single
ReDim vx2sa(0) As Single
ReDim vy1sa(0) As Single
ReDim vy2sa(0) As Single
ReDim ax1sa(0) As Single
ReDim ax2sa(0) As Single
ReDim ay1sa(0) As Single
ReDim ay2sa(0) As Single
ReDim Colors(0) As Long
End Sub
Sub Form_KeyDown (KeyCode As Integer, Shift As Integer)
EndScrnsave ' End screen blanking
End Sub
Sub Form_Load ()
' stretch to full screen
Move 0, 0, Screen.Width, Screen.Height
DrawWidth = 1
'For i = 1 To 10: l = Rnd: Next i' clear first values from Rnd
Randomize
' Initialize variables now
MaxPlotType = 12
PlotType = Rnd * (MaxPlotType + 1)' choose random start place
'PlotType = 8 ' fixed start place
If PlotType > MaxPlotType Then PlotType = 0
PlotInit = False
TimeInterval = 0
MaxTime = MaxChangeMinutes * 60 + Timer ' calculate time in seconds
HideMouse
Repeats = 1 ' number of drawings to make before returning
End Sub
Sub Form_MouseMove (Button As Integer, Shift As Integer, x As Single, y As Single)
If IsEmpty(lastX) Or IsEmpty(lastY) Then
lastX = x
lastY = y
End If
'
' Only unblank the screen if the mouse moves quickly
' enough (more than 2 pixels at one time.
'
If Abs(lastX - x) > 2 Or Abs(lastY - y) > 2 Then
EndScrnsave ' End screen blanking
End If
lastX = x ' Remember last position
lastY = y
End Sub
Sub Kalied ()
' have a line and its mirror images trace across the
' screen with multiple previous copies following
' it
Dim i As Integer, j As Integer, k As Integer, N As Integer
Dim xRadius As Integer, yRadius As Integer
Dim HighMirror As Integer
' if first time then initialize
If PlotInit = False Then
PlotInit = True
Cls
Forecolor = QBColor(15)
'select mirroring method
HighMirror = 3
Mirror = Rnd * HighMirror + 1: If Mirror > HighMirror Then Mirror = 1
'Set array size and clear the elements
ReDim x1a(MaxLines) As Integer
ReDim x2a(MaxLines) As Integer
ReDim y1a(MaxLines) As Integer
ReDim y2a(MaxLines) As Integer
Pointer = 1 ' start with array element 1
' set index to count number of times to repeat color
' to past maxvalue so that it will be recalculated
RepeatIndex = MaxLines + 1
'determine initial position of line
x1 = Rnd * ScaleWidth
x2 = Rnd * ScaleWidth
y1 = Rnd * ScaleHeight
y2 = Rnd * ScaleHeight
'set initial velocity
vx1 = 0
vx2 = 0
vy1 = 0
vy2 = 0
'set initial acceleration
ax1 = 0
ax2 = 0
ay1 = 0
ay2 = 0
'find background color
m = QBColor(0)
'Calculate velocity limits
MaxSpeedX = ScaleWidth * 15! / 800
MaxSpeedY = ScaleWidth * 15! / 600
Else ' put run code here
' check if time to get a new color
If RepeatIndex > RepeatCount Then
' use rgb function
i = Rnd * 255: If i > 255 Then i = 255
j = Rnd * 255: If j > 255 Then j = 255
k = Rnd * 255: If k > 255 Then k = 255
l = RGB(i, j, k)
RepeatIndex = 1
Else
RepeatIndex = RepeatIndex + 1
End If
'Delete original Lines
Select Case Mirror
Case 1: 'mirror on x and y axis
Line (x1a(Pointer), y1a(Pointer))-(x2a(Pointer), y2a(Pointer)), m
Line (ScaleWidth - x1a(Pointer), y1a(Pointer))-(ScaleWidth - x2a(Pointer), y2a(Pointer)), m
Line (x1a(Pointer), ScaleHeight - y1a(Pointer))-(x2a(Pointer), ScaleHeight - y2a(Pointer)), m
Line (ScaleWidth - x1a(Pointer), ScaleHeight - y1a(Pointer))-(ScaleWidth - x2a(Pointer), ScaleHeight - y2a(Pointer)), m
Case 2: 'mirror on Y axis
Line (x1a(Pointer), y1a(Pointer))-(x2a(Pointer), y2a(Pointer)), m
Line (ScaleWidth - x1a(Pointer), y1a(Pointer))-(ScaleWidth - x2a(Pointer), y2a(Pointer)), m
Case 3: 'mirror around center point
Line (x1a(Pointer), y1a(Pointer))-(x2a(Pointer), y2a(Pointer)), m
Line (ScaleWidth - x1a(Pointer), ScaleHeight - y1a(Pointer))-(ScaleWidth - x2a(Pointer), ScaleHeight - y2a(Pointer)), m
Case Else: Mirror = 1' if invalid value set, then change
End Select
'Save New Lines
x1a(Pointer) = x1
x2a(Pointer) = x2
y1a(Pointer) = y1
y2a(Pointer) = y2
'Draw New Lines
Select Case Mirror
Case 1: 'mirror on x and y axis
Line (x1a(Pointer), y1a(Pointer))-(x2a(Pointer), y2a(Pointer)), l
Line (ScaleWidth - x1a(Pointer), y1a(Pointer))-(ScaleWidth - x2a(Pointer), y2a(Pointer)), l
Line (x1a(Pointer), ScaleHeight - y1a(Pointer))-(x2a(Pointer), ScaleHeight - y2a(Pointer)), l
Line (ScaleWidth - x1a(Pointer), ScaleHeight - y1a(Pointer))-(ScaleWidth - x2a(Pointer), ScaleHeight - y2a(Pointer)), l
Case 2: 'mirror on Y axis
Line (x1a(Pointer), y1a(Pointer))-(x2a(Pointer), y2a(Pointer)), l
Line (ScaleWidth - x1a(Pointer), y1a(Pointer))-(ScaleWidth - x2a(Pointer), y2a(Pointer)), l
Case 3: 'mirror around center point
Line (x1a(Pointer), y1a(Pointer))-(x2a(Pointer), y2a(Pointer)), l
Line (ScaleWidth - x1a(Pointer), ScaleHeight - y1a(Pointer))-(ScaleWidth - x2a(Pointer), ScaleHeight - y2a(Pointer)), l
Case Else: Mirror = 1' if invalid value set, then change
End Select
'Move pointer to next item
Pointer = Pointer + 1
If Pointer > MaxLines Then
Pointer = 1
End If
'determine new acceleration
ax1 = Rnd - .5
ax2 = Rnd - .5
ay1 = Rnd - .5
ay2 = Rnd - .5
'calculate new position
x1 = x1 + vx1
x2 = x2 + vx2
y1 = y1 + vy1
y2 = y2 + vy2
'calculate new velocity
vx1 = (vx1 + ax1): If Abs(vx1) > MaxSpeedX Then vx1 = 0: ax1 = 0
vx2 = (vx2 + ax2): If Abs(vx2) > MaxSpeedX Then vx2 = 0: ax2 = 0
vy1 = (vy1 + ay1): If Abs(vy1) > MaxSpeedY Then vy1 = 0: ay1 = 0
vy2 = (vy2 + ay2): If Abs(vy2) > MaxSpeedY Then vy2 = 0: ay2 = 0
'check if off screen
If (x1 > ScaleWidth) Then
'change direction
vx1 = -Abs(vx1)
ElseIf (x1 < 0) Then
'change direction
vx1 = Abs(vx1)
End If
If (y1 > ScaleHeight) Then
'change direction
vy1 = -Abs(vy1)
ElseIf (y1 < 0) Then
'change direction
vy1 = Abs(vy1)
End If
If (x2 > ScaleWidth) Then
'change direction
vx2 = -Abs(vx2)
ElseIf (x2 < 0) Then
'change direction
vx2 = Abs(vx2)
End If
If (y2 > ScaleHeight) Then
'change direction
vy2 = -Abs(vy2)
ElseIf (y2 < 0) Then
'change direction
vy2 = Abs(vy2)
End If
End If
End Sub
Sub Kalied2 ()
' have a line and its mirror images trace across the
' screen with all the previous copies left on the screen
' until the maximum is reached and the screen cleared
Dim i As Integer, j As Integer, k As Integer, N As Integer
Dim xRadius As Integer, yRadius As Integer
Dim HighMirror As Integer
' if first time then initialize
If PlotInit = False Then
PlotInit = True
Cls
Forecolor = QBColor(15)
'select mirroring method
HighMirror = 3
Mirror = Rnd * HighMirror + 1: If Mirror > HighMirror Then Mirror = 1
Pointer = 1 ' set lines on screen to one
' set index to count number of times to repeat color
' to past maxvalue so that it will be recalculated
RepeatIndex = MaxLines + 1
'determine initial position of line
x1 = Rnd * ScaleWidth
x2 = Rnd * ScaleWidth
y1 = Rnd * ScaleHeight
y2 = Rnd * ScaleHeight
'set initial velocity
vx1 = 0
vx2 = 0
vy1 = 0
vy2 = 0
'set initial acceleration
ax1 = 0
ax2 = 0
ay1 = 0
ay2 = 0
'find background color
m = QBColor(0)
'Calculate velocity limits
MaxSpeedX = ScaleWidth * 15! / 800
MaxSpeedY = ScaleWidth * 15! / 600
Else ' put run code here
' check if time to get a new color
If RepeatIndex > RepeatCount Then
' use rgb function
i = Rnd * 255: If i > 255 Then i = 255
j = Rnd * 255: If j > 255 Then j = 255
k = Rnd * 255: If k > 255 Then k = 255
l = RGB(i, j, k)
RepeatIndex = 1
Else
RepeatIndex = RepeatIndex + 1
End If
'Draw New Lines
Select Case Mirror
Case 1: 'mirror on x and y axis
Line (x1, y1)-(x2, y2), l
Line (ScaleWidth - x1, y1)-(ScaleWidth - x2, y2), l
Line (x1, ScaleHeight - y1)-(x2, ScaleHeight - y2), l
Line (ScaleWidth - x1, ScaleHeight - y1)-(ScaleWidth - x2, ScaleHeight - y2), l
Case 2: 'mirror on Y axis
Line (x1, y1)-(x2, y2), l
Line (ScaleWidth - x1, y1)-(ScaleWidth - x2, y2), l
Case 3: 'mirror around center point
Line (x1, y1)-(x2, y2), l
Line (ScaleWidth - x1, ScaleHeight - y1)-(ScaleWidth - x2, ScaleHeight - y2), l
Case Else: Mirror = 1' if invalid value set, then change
End Select
' count total lines on screen
Pointer = Pointer + 1
If Pointer > MaxCums Then
'when maximum reached then clear
Cls
Pointer = 1
End If
'determine new acceleration
ax1 = Rnd - .5
ax2 = Rnd - .5
ay1 = Rnd - .5
ay2 = Rnd - .5
'calculate new position
x1 = x1 + vx1
x2 = x2 + vx2
y1 = y1 + vy1
y2 = y2 + vy2
'calculate new velocity
vx1 = (vx1 + ax1): If Abs(vx1) > MaxSpeedX Then vx1 = 0: ax1 = 0
vx2 = (vx2 + ax2): If Abs(vx2) > MaxSpeedX Then vx2 = 0: ax2 = 0
vy1 = (vy1 + ay1): If Abs(vy1) > MaxSpeedY Then vy1 = 0: ay1 = 0
vy2 = (vy2 + ay2): If Abs(vy2) > MaxSpeedY Then vy2 = 0: ay2 = 0
'check if off screen
If (x1 > ScaleWidth) Then
'change direction
vx1 = -Abs(vx1)
ElseIf (x1 < 0) Then
'change direction
vx1 = Abs(vx1)
End If
If (y1 > ScaleHeight) Then
'change direction
vy1 = -Abs(vy1)
ElseIf (y1 < 0) Then
'change direction
vy1 = Abs(vy1)
End If
If (x2 > ScaleWidth) Then
'change direction
vx2 = -Abs(vx2)
ElseIf (x2 < 0) Then
'change direction
vx2 = Abs(vx2)
End If
If (y2 > ScaleHeight) Then
'change direction
vy2 = -Abs(vy2)
ElseIf (y2 < 0) Then
'change direction
vy2 = Abs(vy2)
End If
End If
End Sub
Sub Lines ()
' have a random number of lines trace across the
' screen with multiple previous copies following
' them
Dim i As Integer, j As Integer, k As Integer, ii As Integer, N As Integer
Static Sets As Integer
' if first time then initialize
If PlotInit = False Then
PlotInit = True
Cls
Forecolor = QBColor(15)
'set number of sets between 1 and 4
Sets = Rnd * 3 + 1
'Set array size and clear the elements
ReDim x1da(MaxLines, Sets) As Integer
ReDim x2da(MaxLines, Sets) As Integer
ReDim y1da(MaxLines, Sets) As Integer
ReDim y2da(MaxLines, Sets) As Integer
ReDim x1sa(Sets) As Single
ReDim x2sa(Sets) As Single
ReDim y1sa(Sets) As Single
ReDim y2sa(Sets) As Single
ReDim vx1sa(Sets) As Single
ReDim vx2sa(Sets) As Single
ReDim vy1sa(Sets) As Single
ReDim vy2sa(Sets) As Single
ReDim ax1sa(Sets) As Single
ReDim ax2sa(Sets) As Single
ReDim ay1sa(Sets) As Single
ReDim ay2sa(Sets) As Single
ReDim Colors(Sets) As Long
Pointer = 1 ' start with array element 1
' set index to count number of times to repeat color
' to past maxvalue so that it will be recalculated
RepeatIndex = MaxLines + 1
For j = 1 To Sets
'determine initial position of line
x1sa(j) = Rnd * ScaleWidth
x2sa(j) = Rnd * ScaleWidth
y1sa(j) = Rnd * ScaleHeight
y2sa(j) = Rnd * ScaleHeight
Next j
'find background color
m = QBColor(0)
'Calculate velocity limits
MaxSpeedX = ScaleWidth * 15! / 800
MaxSpeedY = ScaleWidth * 15! / 600
Else ' put run code here
' check if time to get a new color
If RepeatIndex > RepeatCount Then
' use rgb function
For ii = 1 To Sets
i = Rnd * 255: If i > 255 Then i = 255
j = Rnd * 255: If j > 255 Then j = 255
k = Rnd * 255: If k > 255 Then k = 255
Colors(ii) = RGB(i, j, k)
Next ii
RepeatIndex = 1
Else
RepeatIndex = RepeatIndex + 1
End If
'Delete original Lines
For j = 1 To Sets
Line (x1da(Pointer, j), y1da(Pointer, j))-(x2da(Pointer, j), y2da(Pointer, j)), m
Next j
For j = 1 To Sets
'Save New Lines
x1da(Pointer, j) = x1sa(j)
x2da(Pointer, j) = x2sa(j)
y1da(Pointer, j) = y1sa(j)
y2da(Pointer, j) = y2sa(j)
'Draw new Line
Line (x1da(Pointer, j), y1da(Pointer, j))-(x2da(Pointer, j), y2da(Pointer, j)), Colors(j)
Next j
'Move pointer to next item
Pointer = Pointer + 1
If Pointer > MaxLines Then
Pointer = 1
End If
For j = 1 To Sets
'determine new acceleration
ax1sa(j) = Rnd - .5
ax2sa(j) = Rnd - .5
ay1sa(j) = Rnd - .5
ay2sa(j) = Rnd - .5
'calculate new position
x1sa(j) = x1sa(j) + vx1sa(j)
x2sa(j) = x2sa(j) + vx2sa(j)
y1sa(j) = y1sa(j) + vy1sa(j)
y2sa(j) = y2sa(j) + vy2sa(j)
'calculate new velocity
vx1sa(j) = (vx1sa(j) + ax1sa(j)): If Abs(vx1sa(j)) > MaxSpeedX Then vx1sa(j) = 0: ax1sa(j) = 0
vx2sa(j) = (vx2sa(j) + ax2sa(j)): If Abs(vx2sa(j)) > MaxSpeedX Then vx2sa(j) = 0: ax2sa(j) = 0
vy1sa(j) = (vy1sa(j) + ay1sa(j)): If Abs(vy1sa(j)) > MaxSpeedY Then vy1sa(j) = 0: ay1sa(j) = 0
vy2sa(j) = (vy2sa(j) + ay2sa(j)): If Abs(vy2sa(j)) > MaxSpeedY Then vy2sa(j) = 0: ay2sa(j) = 0
'check if off screen
If (x1sa(j) > ScaleWidth) Then
'change direction
vx1sa(j) = -Abs(vx1sa(j))
ElseIf (x1sa(j) < 0) Then
'change direction
vx1sa(j) = Abs(vx1sa(j))
End If
If (y1sa(j) > ScaleHeight) Then
'change direction
vy1sa(j) = -Abs(vy1sa(j))
ElseIf (y1sa(j) < 0) Then
'change direction
vy1sa(j) = Abs(vy1sa(j))
End If
If (x2sa(j) > ScaleWidth) Then
'change direction
vx2sa(j) = -Abs(vx2sa(j))
ElseIf (x2sa(j) < 0) Then
'change direction
vx2sa(j) = Abs(vx2sa(j))
End If
If (y2sa(j) > ScaleHeight) Then
'change direction
vy2sa(j) = -Abs(vy2sa(j))
ElseIf (y2sa(j) < 0) Then
'change direction
vy2sa(j) = Abs(vy2sa(j))
End If
Next j
End If
End Sub
Sub Patch ()
' copy blocks of original screen to random spots
' if first time then initialize
If PlotInit = False Then
' set tick rate down
Tick.Interval = 250
' start with original screen
Picture = Original.Image
PlotInit = True
Else ' put run code here
BoxHeight = Rnd * ScaleHeight / 2.5
BoxWidth = Rnd * ScaleWidth / 2.5 * (8# / 6#)
' get random locations
x1 = Rnd * ScaleWidth
y1 = Rnd * ScaleHeight
x2 = Rnd * ScaleWidth
y2 = Rnd * ScaleHeight
'make sure room in destination and source blocks
If x1 + BoxWidth > ScaleWidth Then BoxWidth = ScaleWidth - x1
If x2 + BoxWidth > ScaleWidth Then BoxWidth = ScaleWidth - x2
If y1 + BoxHeight > ScaleHeight Then BoxHeight = ScaleHeight - y1
If y2 + BoxHeight > ScaleHeight Then BoxHeight = ScaleHeight - y2
'BitBlt Box from x2,y2 to x1,y1
DC = Original.hDC
BitBlt hDC, x1, y1, BoxWidth, BoxHeight, DC, x2, y2, &HCC0020
End If
End Sub
Sub Polygons ()
' draw a randomly moving polygon on the screen
' with multiple previous copies following it
Dim i As Integer, j As Integer, k As Integer, ii As Integer, N As Integer
Static Sets As Integer
' if first time then initialize
If PlotInit = False Then
PlotInit = True
Cls
Forecolor = QBColor(15)
'set number of sets between 3 and 5
Sets = Rnd * 2 + 3
'Set array size and clear the elements
ReDim x1da(MaxLines, Sets) As Integer
ReDim y1da(MaxLines, Sets) As Integer
ReDim x1sa(Sets) As Single
ReDim y1sa(Sets) As Single
ReDim vx1sa(Sets) As Single
ReDim vy1sa(Sets) As Single
ReDim ax1sa(Sets) As Single
ReDim ay1sa(Sets) As Single
Pointer = 1 ' start with array element 1
' set index to count number of times to repeat color
' to past maxvalue so that it will be recalculated
RepeatIndex = MaxLines + 1
For j = 1 To Sets
'determine initial position of line
x1sa(j) = Rnd * ScaleWidth
y1sa(j) = Rnd * ScaleHeight
Next j
'find background color
m = QBColor(0)
'Calculate velocity limits
MaxSpeedX = ScaleWidth * 15! / 800
MaxSpeedY = ScaleWidth * 15! / 600
Else ' put run code here
' check if time to get a new color
If RepeatIndex > RepeatCount Then
i = Rnd * 255: If i > 255 Then i = 255
j = Rnd * 255: If j > 255 Then j = 255
k = Rnd * 255: If k > 255 Then k = 255
l = RGB(i, j, k)
RepeatIndex = 1
Else
RepeatIndex = RepeatIndex + 1
End If
'Delete original Lines
Line (x1da(Pointer, 1), y1da(Pointer, 1))-(x1da(Pointer, 2), y1da(Pointer, 2)), m
For j = 3 To Sets
Line -(x1da(Pointer, j), y1da(Pointer, j)), m
Next j
Line -(x1da(Pointer, 1), y1da(Pointer, 1)), m
For j = 1 To Sets
'Save New Lines
x1da(Pointer, j) = x1sa(j)
y1da(Pointer, j) = y1sa(j)
Next j
'Draw New Lines
Line (x1da(Pointer, 1), y1da(Pointer, 1))-(x1da(Pointer, 2), y1da(Pointer, 2)), l
For j = 3 To Sets
Line -(x1da(Pointer, j), y1da(Pointer, j)), l
Next j
Line -(x1da(Pointer, 1), y1da(Pointer, 1)), l
'Move pointer to next item
Pointer = Pointer + 1
If Pointer > MaxLines Then
Pointer = 1
End If
For j = 1 To Sets
'determine new acceleration
ax1sa(j) = Rnd - .5
ay1sa(j) = Rnd - .5
'calculate new position
x1sa(j) = x1sa(j) + vx1sa(j)
y1sa(j) = y1sa(j) + vy1sa(j)
'calculate new velocity
vx1sa(j) = (vx1sa(j) + ax1sa(j)): If Abs(vx1sa(j)) > MaxSpeedX Then vx1sa(j) = 0: ax1sa(j) = 0
vy1sa(j) = (vy1sa(j) + ay1sa(j)): If Abs(vy1sa(j)) > MaxSpeedY Then vy1sa(j) = 0: ay1sa(j) = 0
'check if off screen
If (x1sa(j) > ScaleWidth) Then
'change direction
vx1sa(j) = -Abs(vx1sa(j))
ElseIf (x1sa(j) < 0) Then
'change direction
vx1sa(j) = Abs(vx1sa(j))
End If
If (y1sa(j) > ScaleHeight) Then
'change direction
vy1sa(j) = -Abs(vy1sa(j))
ElseIf (y1sa(j) < 0) Then
'change direction
vy1sa(j) = Abs(vy1sa(j))
End If
Next j
End If
End Sub
Sub Puzzle ()
'scramble screen by shifting one column or row at a time
Dim tempx As Integer, tempy As Integer
Dim x As Integer, y As Integer
' if first time then initialize
If PlotInit = False Then
' set tick rate down
Tick.Interval = 1000
' start with original screen
Picture = Original.Image
PlotInit = True
BoxHeight = ScaleHeight / 10
BoxWidth = ScaleWidth / 10
'initialize blocks
ReDim x1da(10, 10) As Integer
ReDim y1da(10, 10) As Integer
For x1 = 1 To 10
For y1 = 1 To 10
x1da(x1, y1) = (x1 - 1) * BoxWidth
y1da(x1, y1) = (y1 - 1) * BoxHeight
Next y1
Next x1
Else ' put run code here
If Int(Rnd * 2) = 1 Then 'shift column
x1 = Rnd * 10 + 1: If x1 > 10 Then x1 = 1
If Int(Rnd * 2) = 1 Then 'shift down
tempx = x1da(x1, 10)
tempy = y1da(x1, 10)
For y1 = 10 To 2 Step -1
x1da(x1, y1) = x1da(x1, y1 - 1)
y1da(x1, y1) = y1da(x1, y1 - 1)
'BitBlt Box to x1,y1
DC = Original.hDC
x = (x1 - 1) * BoxWidth
y = (y1 - 1) * BoxHeight
BitBlt hDC, x, y, BoxWidth, BoxHeight, DC, x1da(x1, y1), y1da(x1, y1), &HCC0020
Next y1
y1 = 1
x1da(x1, y1) = tempx
y1da(x1, y1) = tempy
'BitBlt Box to x1,y1
DC = Original.hDC
x = (x1 - 1) * BoxWidth
y = (y1 - 1) * BoxHeight
BitBlt hDC, x, y, BoxWidth, BoxHeight, DC, x1da(x1, y1), y1da(x1, y1), &HCC0020
Else ' shift up
tempx = x1da(x1, 1)
tempy = y1da(x1, 1)
For y1 = 1 To 9
x1da(x1, y1) = x1da(x1, y1 + 1)
y1da(x1, y1) = y1da(x1, y1 + 1)
'BitBlt Box to x1,y1
DC = Original.hDC
x = (x1 - 1) * BoxWidth
y = (y1 - 1) * BoxHeight
BitBlt hDC, x, y, BoxWidth, BoxHeight, DC, x1da(x1, y1), y1da(x1, y1), &HCC0020
Next y1
y1 = 10
x1da(x1, y1) = tempx
y1da(x1, y1) = tempy
'BitBlt Box to x1,y1
DC = Original.hDC
x = (x1 - 1) * BoxWidth
y = (y1 - 1) * BoxHeight
BitBlt hDC, x, y, BoxWidth, BoxHeight, DC, x1da(x1, y1), y1da(x1, y1), &HCC0020
End If
Else ' shift row
y1 = Rnd * 10 + 1: If y1 > 10 Then y1 = 1
If Int(Rnd * 2) = 1 Then 'shift right
tempx = x1da(10, y1)
tempy = y1da(10, y1)
For x1 = 10 To 2 Step -1
x1da(x1, y1) = x1da(x1 - 1, y1)
y1da(x1, y1) = y1da(x1 - 1, y1)
'BitBlt Box to x1,y1
DC = Original.hDC
x = (x1 - 1) * BoxWidth
y = (y1 - 1) * BoxHeight
BitBlt hDC, x, y, BoxWidth, BoxHeight, DC, x1da(x1, y1), y1da(x1, y1), &HCC0020
Next x1
x1 = 1
x1da(x1, y1) = tempx
y1da(x1, y1) = tempy
'BitBlt Box to x1,y1
DC = Original.hDC
x = (x1 - 1) * BoxWidth
y = (y1 - 1) * BoxHeight
BitBlt hDC, x, y, BoxWidth, BoxHeight, DC, x1da(x1, y1), y1da(x1, y1), &HCC0020
Else 'shift left
tempx = x1da(1, y1)
tempy = y1da(1, y1)
For x1 = 1 To 9
x1da(x1, y1) = x1da(x1 + 1, y1)
y1da(x1, y1) = y1da(x1 + 1, y1)
'BitBlt Box to x1,y1
DC = Original.hDC
x = (x1 - 1) * BoxWidth
y = (y1 - 1) * BoxHeight
BitBlt hDC, x, y, BoxWidth, BoxHeight, DC, x1da(x1, y1), y1da(x1, y1), &HCC0020
Next x1
x1 = 10
x1da(x1, y1) = tempx
y1da(x1, y1) = tempy
'BitBlt Box to x1,y1
DC = Original.hDC
x = (x1 - 1) * BoxWidth
y = (y1 - 1) * BoxHeight
BitBlt hDC, x, y, BoxWidth, BoxHeight, DC, x1da(x1, y1), y1da(x1, y1), &HCC0020
End If
End If
End If
End Sub
Sub Roll ()
' the display rolls both horizontally and vertically
Dim v As Integer
' if first time then initialize
If PlotInit = False Then
' start with original screen
Picture = Original.Image
PlotInit = True
'Calculate velocity limits
MaxSpeedX = ScaleWidth * 15! / 800
MaxSpeedY = ScaleWidth * 15! / 600
' initial velocities
vy1 = 0: vx1 = 0
' initial offset
x1 = 0: y1 = 0
Direction = Rnd * 2: If Direction > 1 Then Direction = 0
Else ' put run code here
DC = Original.hDC
If Direction Then
' do vertical scroll
BitBlt hDC, 0, y1, ScaleWidth, ScaleHeight - y1, DC, 0, 0, &HCC0020
BitBlt hDC, 0, 0, ScaleWidth, y1, DC, 0, ScaleHeight - y1, &HCC0020
Else
' do horizontal scroll
BitBlt hDC, x1, 0, ScaleWidth - x1, ScaleHeight, DC, 0, 0, &HCC0020
BitBlt hDC, 0, 0, x1, ScaleHeight, DC, ScaleWidth - x1, 0, &HCC0020
End If
'determine new acceleration
ax1 = Rnd - .5
ay1 = Rnd - .5
'calculate new velocity
vx1 = (vx1 + ax1): If Abs(vx1) > MaxSpeedX Then vx1 = 0: ax1 = 0
vy1 = (vy1 + ay1): If Abs(vy1) > MaxSpeedY Then vy1 = 0: ay1 = 0
'find new roll amount
x1 = x1 + vx1
If x1 > ScaleWidth Then
x1 = x1 - ScaleWidth
Else
If x1 < 0 Then
x1 = x1 + ScaleWidth
End If
End If
y1 = y1 + vy1
If y1 > ScaleHeight Then
y1 = y1 - ScaleHeight
Else
If y1 < 0 Then
y1 = y1 + ScaleHeight
End If
End If
End If
End Sub
Sub Scrape ()
' bitblt's with various patterns, dragging them
' across the screen randomly
' if first time then initialize
If PlotInit = False Then
' start with original screen
Picture = Original.Image
PlotInit = True
'determine initial position of line
x1 = Rnd * ScaleWidth
y1 = Rnd * ScaleHeight
x2 = Rnd * ScaleWidth
y2 = Rnd * ScaleHeight
'Calculate velocity limits
MaxSpeedX = ScaleWidth * 15! / 800
MaxSpeedY = ScaleWidth * 15! / 600
BoxHeight = 400 * Rnd ^ 3 + 20
BoxWidth = (400 * Rnd ^ 3 + 20) * (8# / 6#)
' zero initial velocity
vx1 = 0: vy1 = 0
' choose scrape type at random
i = Rnd * 16
Select Case i
Case 0: Pattern = &H42 'Black Out
Locked = True
Case 1: Pattern = &HFF0062 'White Out
Locked = True
Case 2: Pattern = &HBB0226 'MergePaint
Locked = False
Case 3: Pattern = &HCC0020 'Source Copy
Locked = False
Case 4: Pattern = &HCC0020 'Source Copy
Locked = True
Picture = LoadPicture() ' start with blank screen
Case 5: Pattern = &H330008 'Not source copy
Locked = True
Case 6: Pattern = &H330008 'Not source copy
Locked = False
Case 7: Pattern = &H1100A6 'not source erase
Locked = True
Case 8: Pattern = &H1100A6 'not source erase
Locked = False
Case 9: Pattern = &H440328 'source erase
Locked = True
Case 10: Pattern = &H440328 'source erase
Locked = False
Case 11: Pattern = &H660046 'source invert
Locked = True
Case 12: Pattern = &H660046 'source invert
Locked = False
Case 13: Pattern = &H8800C6 'source and
Locked = False
Case 14: Pattern = &HEE0086 'source paint
Locked = False
Case Else: Pattern = &H550009 'Invert Destination
Locked = True
End Select
Else ' put run code here
' do locking if necessary
If Locked Then
x2 = x1: y2 = y1
Else 'do offset
x2 = x1 + BoxWidth: If x2 + BoxWidth > ScaleWidth Then x2 = 0
y2 = y1 + BoxHeight: If y2 + BoxHeight > ScaleHeight Then y2 = 0
End If
'BitBlt Box at x1,y1
DC = Original.hDC
BitBlt hDC, x1, y1, BoxWidth, BoxHeight, DC, x2, y2, Pattern
'determine new acceleration
ax1 = Rnd - .5
ay1 = Rnd - .5
'calculate new position
x1 = x1 + vx1
y1 = y1 + vy1
'calculate new velocity
vx1 = (vx1 + ax1): If Abs(vx1) > MaxSpeedX Then vx1 = 0: ax1 = 0
vy1 = (vy1 + ay1): If Abs(vy1) > MaxSpeedY Then vy1 = 0: ay1 = 0
'check if off screen
If (x1 > ScaleWidth - BoxWidth) Then
'change direction
vx1 = -Abs(vx1)
ElseIf (x1 < 0) Then
'change direction
vx1 = Abs(vx1)
End If
If (y1 > ScaleHeight - BoxHeight) Then
'change direction
vy1 = -Abs(vy1)
ElseIf (y1 < 0) Then
'change direction
vy1 = Abs(vy1)
End If
End If
End Sub
Sub Squiggles ()
' draw multiple squiggles on the screen.
' each squiggle is assign a random color at the
' start, then the head travels randomly and the
' tail is erased
Dim i As Integer, j As Integer, k As Integer, ii As Integer, N As Integer
Static SquigNumb As Integer
Static SquigLen As Integer
Static EndPointer As Integer, StartPointer As Integer
' if first time then initialize
If PlotInit = False Then
PlotInit = True
Cls
Forecolor = QBColor(15)
SquigNumb = Rnd * 10 + 10
SquigLen = Rnd * 100 + 50
'Allocate Memory
ReDim x1da(SquigLen, SquigNumb) As Integer
ReDim y1da(SquigLen, SquigNumb) As Integer
ReDim x1sa(SquigNumb) As Single
ReDim y1sa(SquigNumb) As Single
ReDim vx1sa(SquigNumb) As Single
ReDim vy1sa(SquigNumb) As Single
ReDim ax1sa(SquigNumb) As Single
ReDim ay1sa(SquigNumb) As Single
ReDim Colors(SquigNumb) As Long
Pointer = 1
'Print "Clearing Array"
For j = 1 To SquigNumb
'determine initial position of line
x1sa(j) = Rnd * ScaleWidth
y1sa(j) = Rnd * ScaleHeight
For i = 1 To SquigLen
x1da(i, j) = x1sa(j)
y1da(i, j) = y1sa(j)
Next i
Next j
'find background color
m = QBColor(0)
' use rgb function to get colors
For ii = 1 To SquigNumb
i = Rnd * 255: If i > 255 Then i = 255
j = Rnd * 255: If j > 255 Then j = 255
k = Rnd * 255: If k > 255 Then k = 255
Colors(ii) = RGB(i, j, k)
Next ii
'Calculate velocity limits
MaxSpeedX = ScaleWidth * 15! / 800
MaxSpeedY = ScaleWidth * 15! / 600
Else ' put run code here
'find where tail line went to
If Pointer < SquigLen Then
EndPointer = Pointer + 1
Else
EndPointer = 1
End If
'find where new line goes
If Pointer > 1 Then
StartPointer = Pointer - 1
Else
StartPointer = SquigLen
End If
For j = 1 To SquigNumb
'Erase tails of squigles
Line (x1da(Pointer, j), y1da(Pointer, j))-(x1da(EndPointer, j), y1da(EndPointer, j)), m
'Save new points
x1da(Pointer, j) = x1sa(j)
y1da(Pointer, j) = y1sa(j)
'Draw front of Squigles
Line (x1da(StartPointer, j), y1da(StartPointer, j))-(x1da(Pointer, j), y1da(Pointer, j)), Colors(j)
Next j
'Move pointer to next item
Pointer = Pointer + 1
If Pointer > SquigLen Then
Pointer = 1
End If
For j = 1 To SquigNumb
'determine new acceleration
ax1sa(j) = Rnd * 4 - 2
ay1sa(j) = Rnd * 4 - 2
'calculate new position
x1sa(j) = x1sa(j) + vx1sa(j)
y1sa(j) = y1sa(j) + vy1sa(j)
'calculate new velocity
vx1sa(j) = (vx1sa(j) + ax1sa(j)): If Abs(vx1sa(j)) > 20 Then vx1sa(j) = 0: ax1sa(j) = 0
vy1sa(j) = (vy1sa(j) + ay1sa(j)): If Abs(vy1sa(j)) > 20 Then vy1sa(j) = 0: ay1sa(j) = 0
'check if off screen
If (x1sa(j) > ScaleWidth) Then
x1sa(j) = ScaleWidth
'change direction
vx1sa(j) = -Abs(vx1sa(j))
ElseIf (x1sa(j) < 0) Then
x1sa(j) = 0
'change direction
vx1sa(j) = Abs(vx1sa(j))
End If
If (y1sa(j) > ScaleHeight) Then
y1sa(j) = ScaleHeight
'change direction
vy1sa(j) = -Abs(vy1sa(j))
ElseIf (y1sa(j) < 0) Then
y1sa(j) = 0
'change direction
vy1sa(j) = Abs(vy1sa(j))
End If
Next j
End If
End Sub
Sub Tick_Timer ()
' check elapsed time to see if need to change type of plot
' also check if past midnight
CurrentTime = Timer
If (CurrentTime > MaxTime) Or (LastTime > CurrentTime) Then
MaxTime = MaxChangeMinutes * 60 + CurrentTime ' calculate time in seconds
' get new plottype, but make sure it is not
' the same as the current one
Do
i = Rnd * (MaxPlotType + 1) 'choose next one at random
If i > MaxPlotType Then i = 0
Loop While (i = PlotType)
PlotType = i
PlotInit = False
Picture = LoadPicture()
BackGround.AutoRedraw = False
ClearArrays 'set arrays to zero size when not needed
'reset tick rate
Tick.Interval = 50
End If
LastTime = CurrentTime
Select Case PlotType
Case 0: Squiggles
Case 1: Kalied2
Case 2: Polygons
Case 3: Circles
Case 4: Kalied
Case 5: Lines
Case 6: Roll
Case 7: Patch
Case 8: Puzzle
Case 9: Scrape
Case 10: Scrape ' will be used twice as often
Case Else: PlotType = 0
End Select
End Sub